home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / emacs.scm.z / emacs.scm
Encoding:
Text File  |  1999-04-16  |  7.5 KB  |  260 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; The author can be reached at djurfeldt@nada.kth.se
  19. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  20. ;;;; (I didn't write this!)
  21. ;;;;
  22.  
  23.  
  24. ;;; *********************************************************************
  25. ;;; * This is the Guile side of the Emacs interface                     *
  26. ;;; * Experimental hACK---the real version will be coming soon (almost) *
  27. ;;; *********************************************************************
  28.  
  29. ;;; {Session support for Emacs}
  30. ;;;
  31.  
  32. (define-module (ice-9 emacs)
  33.   :use-module (ice-9 debug)
  34.   :use-module (ice-9 threads)
  35.   :use-module (ice-9 session))
  36.  
  37. (define emacs-escape-character #\sub)
  38.  
  39. (define emacs-output-port (current-output-port))
  40.  
  41. (define (make-emacs-command char)
  42.   (let ((cmd (list->string (list emacs-escape-character char))))
  43.     (lambda ()
  44.       (display cmd emacs-output-port))))
  45.  
  46. (define enter-input-wait  (make-emacs-command #\s))
  47. (define exit-input-wait   (make-emacs-command #\f))
  48. (define enter-read-character #\r)
  49. (define sending-error      (make-emacs-command #\F))
  50. (define sending-backtrace (make-emacs-command #\B))
  51. (define sending-result    (make-emacs-command #\x))
  52. (define end-of-text      (make-emacs-command #\.))
  53. (define no-stack      (make-emacs-command #\S))
  54. (define no-source      (make-emacs-command #\R))
  55.  
  56. ;; {Error handling}
  57. ;;
  58.  
  59. (add-hook! before-backtrace-hook sending-backtrace)
  60. (add-hook! after-backtrace-hook end-of-text)
  61. (add-hook! before-error-hook sending-error)
  62. (add-hook! after-error-hook end-of-text)
  63.  
  64. ;; {Repl}
  65. ;;
  66.  
  67. (set-current-error-port emacs-output-port)
  68.  
  69. (add-hook! before-read-hook
  70.        (lambda ()
  71.          (enter-input-wait)
  72.          (force-output emacs-output-port)))
  73.  
  74. (add-hook! after-read-hook
  75.        (lambda ()
  76.          (exit-input-wait)
  77.          (force-output emacs-output-port)))
  78.  
  79. ;;; {Misc.}
  80.  
  81. (define (make-emacs-load-port orig-port)
  82.   (letrec ((read-char-fn  (lambda args
  83.                 (let ((c (read-char orig-port)))
  84.                   (if (eq? c #\soh)
  85.                   (throw 'end-of-chunk)
  86.                   c)))))
  87.     
  88.     (make-soft-port
  89.      (vector #f #f #f
  90.          read-char-fn
  91.          (lambda () (close-port orig-port)))
  92.      "r")))
  93.  
  94. (set-current-input-port (make-emacs-load-port (current-input-port)))
  95.  
  96. (define (result-to-emacs exp)
  97.   (sending-result)
  98.   (write exp emacs-output-port)
  99.   (end-of-text)
  100.   (force-output emacs-output-port))
  101.  
  102. (define load-acknowledge (make-emacs-command #\l))
  103.  
  104. (define load-port (current-input-port))
  105.  
  106. (define (flush-line port)
  107.   (let loop ((c (read-char port)))
  108.     (if (not (eq? c #\nl))
  109.     (loop (read-char port)))))
  110.  
  111. (define whitespace-chars (list #\space #\tab #\nl #\np))
  112.  
  113. (define (flush-whitespace port)
  114.   (catch 'end-of-chunk
  115.      (lambda ()
  116.        (let loop ((c (read-char port)))
  117.          (cond ((eq? c the-eof-object)
  118.             (error "End of file while recieving Emacs data"))
  119.            ((memq c whitespace-chars) (loop (read-char port)))
  120.            ((eq? c #\;) (flush-line port) (loop (read-char port)))
  121.            (else (unread-char c port))))
  122.        #f)
  123.      (lambda args
  124.        (read-char port) ; Read final newline
  125.        #t)))
  126.  
  127. (define (emacs-load filename linum colnum module interactivep)
  128.   (set-port-filename! %%load-port filename)
  129.   (set-port-line! %%load-port linum)
  130.   (set-port-column! %%load-port colnum)
  131.   (lazy-catch #t
  132.           (lambda ()
  133.         (let loop ((endp (flush-whitespace %%load-port)))
  134.           (if (not endp)
  135.               (begin
  136.             (save-module-excursion
  137.              (lambda ()
  138.                (if module
  139.                    (set-current-module (resolve-module module #f)))
  140.                (let ((result
  141.                   (start-stack read-and-eval!
  142.                            (read-and-eval! %%load-port))))
  143.                  (if interactivep
  144.                  (result-to-emacs result)))))
  145.             (loop (flush-whitespace %%load-port)))
  146.               (begin
  147.             (load-acknowledge))))
  148.         )
  149.           (lambda (key . args)
  150.         (cond ((eq? key 'end-of-chunk)
  151.                (fluid-set! the-last-stack #f)
  152.                (set! stack-saved? #t)
  153.                (scm-error 'misc-error
  154.                   #f
  155.                   "Incomplete expression"
  156.                   '()
  157.                   '()))
  158.               ((eq? key 'exit))
  159.               (else
  160.                (save-stack 2)
  161.                (catch 'end-of-chunk
  162.                   (lambda ()
  163.                 (let loop ()
  164.                   (read-char %%load-port)
  165.                   (loop)))
  166.                   (lambda args
  167.                 #f))
  168.                (apply throw key args))))))
  169.  
  170. (define (emacs-eval-request form)
  171.   (result-to-emacs (eval form)))
  172.  
  173. ;;*fixme* Not necessary to use flags no-stack and no-source
  174. (define (get-frame-source frame)
  175.   (if (or (not (fluid-ref the-last-stack))
  176.       (>= frame (stack-length (fluid-ref the-last-stack))))
  177.       (begin
  178.     (no-stack)
  179.     #f)
  180.       (let* ((frame (stack-ref (fluid-ref the-last-stack)
  181.                    (frame-number->index frame)))
  182.          (source (frame-source frame)))
  183.     (or source
  184.         (begin (no-source)
  185.            #f)))))
  186.  
  187. (define (emacs-select-frame frame)
  188.   (let ((source (get-frame-source frame)))
  189.     (if source
  190.     (let ((fname (source-property source 'filename))
  191.           (line (source-property source 'line))
  192.           (column (source-property source 'column)))
  193.       (if (and fname line column)
  194.           (list fname line column)
  195.           (begin (no-source)
  196.              '())))
  197.     '())))
  198.  
  199. (define (object->string x . method)
  200.   (with-output-to-string
  201.     (lambda ()
  202.       ((if (null? method)
  203.        write
  204.        (car method))
  205.        x))))
  206.  
  207. (define (format template . rest)
  208.   (let loop ((chars (string->list template))
  209.          (result '()))
  210.     (cond ((null? chars) (list->string (reverse result)))
  211.       ((char=? (car chars) #\%)
  212.        (loop (cddr chars)
  213.          (append (reverse
  214.               (string->list
  215.                (case (cadr chars)
  216.                  ((#\S) (object->string (car rest)))
  217.                  ((#\s) (object->string (car rest) display)))))
  218.              result)))
  219.       (else (loop (cdr chars) (cons (car chars) result))))))
  220.  
  221. (define (error-args->string args)
  222.   (let ((msg (apply format (caddr args) (cadddr args))))
  223.     (if (symbol? (cadr args))
  224.     (string-append (symbol->string (cadr args))
  225.                ": "
  226.                msg)
  227.     msg)))
  228.  
  229. (define (emacs-frame-eval frame form)
  230.   (let ((source (get-frame-source frame)))
  231.     (if source
  232.     (catch #t
  233.            (lambda ()
  234.          (list 'result
  235.                (object->string
  236.             (local-eval (with-input-from-string form read)
  237.                     (memoized-environment source)))))
  238.            (lambda args
  239.          (list (car args)
  240.                (error-args->string args))))
  241.     (begin
  242.       (no-source)
  243.       '()))))
  244.  
  245. (define (emacs-symdoc symbol)
  246.   (if (or (not (module-bound? (current-module) symbol))
  247.       (not (procedure? (eval symbol))))
  248.       'nil
  249.       (procedure-documentation (eval symbol))))
  250.  
  251. ;;; A fix to get the emacs interface to work together with the module system.
  252. ;;;
  253. (variable-set! (builtin-variable '%%load-port) load-port)
  254. (variable-set! (builtin-variable '%%emacs-load) emacs-load)
  255. (variable-set! (builtin-variable '%%emacs-eval-request) emacs-eval-request)
  256. (variable-set! (builtin-variable '%%emacs-select-frame) emacs-select-frame)
  257. (variable-set! (builtin-variable '%%emacs-frame-eval) emacs-frame-eval)
  258. (variable-set! (builtin-variable '%%emacs-symdoc) emacs-symdoc)
  259. (variable-set! (builtin-variable '%%apropos-internal) apropos-internal)
  260.